home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / share / multimed / myflix_win32 / myflix_win32.exe / data1.cab / Libraries / tk8.0 / Menu.tcl < prev    next >
Text File  |  1998-03-10  |  33KB  |  1,193 lines
  1. # menu.tcl --
  2. #
  3. # This file defines the default bindings for Tk menus and menubuttons.
  4. # It also implements keyboard traversal of menus and implements a few
  5. # other utility procedures related to menus.
  6. #
  7. # SCCS: @(#) menu.tcl 1.97 97/08/13 10:58:34
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. #-------------------------------------------------------------------------
  17. # Elements of tkPriv that are used in this file:
  18. #
  19. # cursor -        Saves the -cursor option for the posted menubutton.
  20. # focus -        Saves the focus during a menu selection operation.
  21. #            Focus gets restored here when the menu is unposted.
  22. # grabGlobal -        Used in conjunction with tkPriv(oldGrab):  if
  23. #            tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal)
  24. #            contains either an empty string or "-global" to
  25. #            indicate whether the old grab was a local one or
  26. #            a global one.
  27. # inMenubutton -    The name of the menubutton widget containing
  28. #            the mouse, or an empty string if the mouse is
  29. #            not over any menubutton.
  30. # menuBar -        The name of the menubar that is the root
  31. #            of the cascade hierarchy which is currently
  32. #            posted. This is null when there is no menu currently
  33. #            being pulled down from a menu bar.
  34. # oldGrab -        Window that had the grab before a menu was posted.
  35. #            Used to restore the grab state after the menu
  36. #            is unposted.  Empty string means there was no
  37. #            grab previously set.
  38. # popup -        If a menu has been popped up via tk_popup, this
  39. #            gives the name of the menu.  Otherwise this
  40. #            value is empty.
  41. # postedMb -        Name of the menubutton whose menu is currently
  42. #            posted, or an empty string if nothing is posted
  43. #            A grab is set on this widget.
  44. # relief -        Used to save the original relief of the current
  45. #            menubutton.
  46. # window -        When the mouse is over a menu, this holds the
  47. #            name of the menu;  it's cleared when the mouse
  48. #            leaves the menu.
  49. # tearoff -        Whether the last menu posted was a tearoff or not.
  50. #            This is true always for unix, for tearoffs for Mac
  51. #            and Windows.
  52. #-------------------------------------------------------------------------
  53.  
  54. #-------------------------------------------------------------------------
  55. # Overall note:
  56. # This file is tricky because there are four different ways that menus
  57. # can be used:
  58. #
  59. # 1. As a pulldown from a menubutton.  This is the most common usage.
  60. #    In this style, the variable tkPriv(postedMb) identifies the posted
  61. #    menubutton.
  62. # 2. As a torn-off menu copied from some other menu.  In this style
  63. #    tkPriv(postedMb) is empty, and the top-level menu is no
  64. #    override-redirect.
  65. # 3. As an option menu, triggered from an option menubutton.  In thi
  66. #    style tkPriv(postedMb) identifies the posted menubutton.
  67. # 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
  68. #    the top-level menu is override-redirect.
  69. #
  70. # The various binding procedures use the  state described above to
  71. # distinguish the various cases and take different actions in each
  72. # case.
  73. #-------------------------------------------------------------------------
  74.  
  75. #-------------------------------------------------------------------------
  76. # The code below creates the default class bindings for menus
  77. # and menubuttons.
  78. #-------------------------------------------------------------------------
  79.  
  80. bind Menubutton <FocusIn> {}
  81. bind Menubutton <Enter> {
  82.     tkMbEnter %W
  83. }
  84. bind Menubutton <Leave> {
  85.     tkMbLeave %W
  86. }
  87. bind Menubutton <1> {
  88.     if {$tkPriv(inMenubutton) != ""} {
  89.     tkMbPost $tkPriv(inMenubutton) %X %Y
  90.     }
  91. }
  92. bind Menubutton <Motion> {
  93.     tkMbMotion %W up %X %Y
  94. }
  95. bind Menubutton <B1-Motion> {
  96.     tkMbMotion %W down %X %Y
  97. }
  98. bind Menubutton <ButtonRelease-1> {
  99.     tkMbButtonUp %W
  100. }
  101. bind Menubutton <space> {
  102.     tkMbPost %W
  103.     tkMenuFirstEntry [%W cget -menu]
  104. }
  105.  
  106. # Must set focus when mouse enters a menu, in order to allow
  107. # mixed-mode processing using both the mouse and the keyboard.
  108. # Don't set the focus if the event comes from a grab release,
  109. # though:  such an event can happen after as part of unposting
  110. # a cascaded chain of menus, after the focus has already been
  111. # restored to wherever it was before menu selection started.
  112.  
  113. bind Menu <FocusIn> {}
  114.  
  115. bind Menu <Enter> {
  116.     set tkPriv(window) %W
  117.     if {[%W cget -type] == "tearoff"} {
  118.     if {"%m" != "NotifyUngrab"} {
  119.         if {$tcl_platform(platform) == "unix"} {
  120.         tk_menuSetFocus %W
  121.         }
  122.     }
  123.     }
  124.     tkMenuMotion %W %x %y %s
  125. }
  126.  
  127. bind Menu <Leave> {
  128.     tkMenuLeave %W %X %Y %s
  129. }
  130. bind Menu <Motion> {
  131.     tkMenuMotion %W %x %y %s
  132. }
  133. bind Menu <ButtonPress> {
  134.     tkMenuButtonDown %W
  135. }
  136. bind Menu <ButtonRelease> {
  137.    tkMenuInvoke %W 1
  138. }
  139. bind Menu <space> {
  140.     tkMenuInvoke %W 0
  141. }
  142. bind Menu <Return> {
  143.     tkMenuInvoke %W 0
  144. }
  145. bind Menu <Escape> {
  146.     tkMenuEscape %W
  147. }
  148. bind Menu <Left> {
  149.     tkMenuLeftArrow %W
  150. }
  151. bind Menu <Right> {
  152.     tkMenuRightArrow %W
  153. }
  154. bind Menu <Up> {
  155.     tkMenuUpArrow %W
  156. }
  157. bind Menu <Down> {
  158.     tkMenuDownArrow %W
  159. }
  160. bind Menu <KeyPress> {
  161.     tkTraverseWithinMenu %W %A
  162. }
  163.  
  164. # The following bindings apply to all windows, and are used to
  165. # implement keyboard menu traversal.
  166.  
  167. if {$tcl_platform(platform) == "unix"} {
  168.     bind all <Alt-KeyPress> {
  169.     tkTraverseToMenu %W %A
  170.     }
  171.  
  172.     bind all <F10> {
  173.     tkFirstMenu %W
  174.     }
  175. } else {
  176.     bind Menubutton <Alt-KeyPress> {
  177.     tkTraverseToMenu %W %A
  178.     }
  179.  
  180.     bind Menubutton <F10> {
  181.     tkFirstMenu %W
  182.     }
  183. }
  184.  
  185. # tkMbEnter --
  186. # This procedure is invoked when the mouse enters a menubutton
  187. # widget.  It activates the widget unless it is disabled.  Note:
  188. # this procedure is only invoked when mouse button 1 is *not* down.
  189. # The procedure tkMbB1Enter is invoked if the button is down.
  190. #
  191. # Arguments:
  192. # w -            The  name of the widget.
  193.  
  194. proc tkMbEnter w {
  195.     global tkPriv
  196.  
  197.     if {$tkPriv(inMenubutton) != ""} {
  198.     tkMbLeave $tkPriv(inMenubutton)
  199.     }
  200.     set tkPriv(inMenubutton) $w
  201.     if {[$w cget -state] != "disabled"} {
  202.     $w configure -state active
  203.     }
  204. }
  205.  
  206. # tkMbLeave --
  207. # This procedure is invoked when the mouse leaves a menubutton widget.
  208. # It de-activates the widget, if the widget still exists.
  209. #
  210. # Arguments:
  211. # w -            The  name of the widget.
  212.  
  213. proc tkMbLeave w {
  214.     global tkPriv
  215.  
  216.     set tkPriv(inMenubutton) {}
  217.     if ![winfo exists $w] {
  218.     return
  219.     }
  220.     if {[$w cget -state] == "active"} {
  221.     $w configure -state normal
  222.     }
  223. }
  224.  
  225. # tkMbPost --
  226. # Given a menubutton, this procedure does all the work of posting
  227. # its associated menu and unposting any other menu that is currently
  228. # posted.
  229. #
  230. # Arguments:
  231. # w -            The name of the menubutton widget whose menu
  232. #            is to be posted.
  233. # x, y -        Root coordinates of cursor, used for positioning
  234. #            option menus.  If not specified, then the center
  235. #            of the menubutton is used for an option menu.
  236.  
  237. proc tkMbPost {w {x {}} {y {}}} {
  238.     global tkPriv errorInfo
  239.     global tcl_platform
  240.  
  241.     if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} {
  242.     return
  243.     }
  244.     set menu [$w cget -menu]
  245.     if {$menu == ""} {
  246.     return
  247.     }
  248.     set tearoff [expr {($tcl_platform(platform) == "unix") \
  249.              || ([$menu cget -type] == "tearoff")}]
  250.     if {[string first $w $menu] != 0} {
  251.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  252.     }
  253.     set cur $tkPriv(postedMb)
  254.     if {$cur != ""} {
  255.     tkMenuUnpost {}
  256.     }
  257.     set tkPriv(cursor) [$w cget -cursor]
  258.     set tkPriv(relief) [$w cget -relief]
  259.     $w configure -cursor arrow
  260.     $w configure -relief raised
  261.  
  262.     set tkPriv(postedMb) $w
  263.     set tkPriv(focus) [focus]
  264.     $menu activate none
  265.     event generate $menu <<MenuSelect>>
  266.  
  267.     # If this looks like an option menubutton then post the menu so
  268.     # that the current entry is on top of the mouse.  Otherwise post
  269.     # the menu just below the menubutton, as for a pull-down.
  270.  
  271.     update idletasks
  272.     if [catch {
  273.          switch [$w cget -direction] {
  274.             above {
  275.                 set x [winfo rootx $w]
  276.                 set y [expr [winfo rooty $w] - [winfo reqheight $menu]]
  277.                 $menu post $x $y
  278.             }
  279.             below {
  280.                 set x [winfo rootx $w]
  281.                 set y [expr [winfo rooty $w] + [winfo height $w]]
  282.                 $menu post $x $y
  283.             }
  284.             left {
  285.                 set x [expr [winfo rootx $w] - [winfo reqwidth $menu]]
  286.                 set y [expr (2 * [winfo rooty $w] + [winfo height $w]) / 2]
  287.                 set entry [tkMenuFindName $menu [$w cget -text]]
  288.                 if [$w cget -indicatoron] {
  289.             if {$entry == [$menu index last]} {
  290.                 incr y [expr -([$menu yposition $entry] \
  291.                     + [winfo reqheight $menu])/2]
  292.             } else {
  293.                 incr y [expr -([$menu yposition $entry] \
  294.                     + [$menu yposition [expr $entry+1]])/2]
  295.             }
  296.                 }
  297.                 $menu post $x $y
  298.                 if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  299.                     $menu activate $entry
  300.             event generate $menu <<MenuSelect>>
  301.                 }
  302.             }
  303.             right {
  304.                 set x [expr [winfo rootx $w] + [winfo width $w]]
  305.                 set y [expr (2 * [winfo rooty $w] + [winfo height $w]) / 2]
  306.                 set entry [tkMenuFindName $menu [$w cget -text]]
  307.                 if [$w cget -indicatoron] {
  308.             if {$entry == [$menu index last]} {
  309.                 incr y [expr -([$menu yposition $entry] \
  310.                     + [winfo reqheight $menu])/2]
  311.             } else {
  312.                 incr y [expr -([$menu yposition $entry] \
  313.                     + [$menu yposition [expr $entry+1]])/2]
  314.             }
  315.                 }
  316.                 $menu post $x $y
  317.                 if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  318.                     $menu activate $entry
  319.             event generate $menu <<MenuSelect>>
  320.                 }
  321.             }
  322.             default {
  323.                 if [$w cget -indicatoron] {
  324.                 if {$y == ""} {
  325.             set x [expr [winfo rootx $w] + [winfo width $w]/2]
  326.             set y [expr [winfo rooty $w] + [winfo height $w]/2]
  327.                 }
  328.                 tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
  329.         } else {
  330.                 $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  331.                 }  
  332.             }
  333.          }
  334.      } msg] {
  335.     # Error posting menu (e.g. bogus -postcommand). Unpost it and
  336.     # reflect the error.
  337.     
  338.     set savedInfo $errorInfo
  339.     tkMenuUnpost {}
  340.     error $msg $savedInfo
  341.  
  342.     }
  343.  
  344.     set tkPriv(tearoff) $tearoff
  345.     if {$tearoff != 0} {
  346.         focus $menu
  347.         tkSaveGrabInfo $w
  348.         grab -global $w
  349.     }
  350. }
  351.  
  352. # tkMenuUnpost --
  353. # This procedure unposts a given menu, plus all of its ancestors up
  354. # to (and including) a menubutton, if any.  It also restores various
  355. # values to what they were before the menu was posted, and releases
  356. # a grab if there's a menubutton involved.  Special notes:
  357. # 1. It's important to unpost all menus before releasing the grab, so
  358. #    that any Enter-Leave events (e.g. from menu back to main
  359. #    application) have mode NotifyGrab.
  360. # 2. Be sure to enclose various groups of commands in "catch" so that
  361. #    the procedure will complete even if the menubutton or the menu
  362. #    or the grab window has been deleted.
  363. #
  364. # Arguments:
  365. # menu -        Name of a menu to unpost.  Ignored if there
  366. #            is a posted menubutton.
  367.  
  368. proc tkMenuUnpost menu {
  369.     global tcl_platform
  370.     global tkPriv
  371.     set mb $tkPriv(postedMb)
  372.  
  373.     # Restore focus right away (otherwise X will take focus away when
  374.     # the menu is unmapped and under some window managers (e.g. olvwm)
  375.     # we'll lose the focus completely).
  376.  
  377.     catch {focus $tkPriv(focus)}
  378.     set tkPriv(focus) ""
  379.  
  380.     # Unpost menu(s) and restore some stuff that's dependent on
  381.     # what was posted.
  382.  
  383.     catch {
  384.     if {$mb != ""} {
  385.         set menu [$mb cget -menu]
  386.         $menu unpost
  387.         set tkPriv(postedMb) {}
  388.         $mb configure -cursor $tkPriv(cursor)
  389.         $mb configure -relief $tkPriv(relief)
  390.     } elseif {$tkPriv(popup) != ""} {
  391.         $tkPriv(popup) unpost
  392.         set tkPriv(popup) {}
  393.     } elseif {(!([$menu cget -type] == "menubar")
  394.         && !([$menu cget -type] == "tearoff"))
  395.         || [wm overrideredirect $menu]} {
  396.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  397.         # Unpost all the menus up to the toplevel one (but not
  398.         # including the top-level torn-off one) and deactivate the
  399.         # top-level torn off menu if there is one.
  400.  
  401.         while 1 {
  402.         set parent [winfo parent $menu]
  403.         if {([winfo class $parent] != "Menu")
  404.             || ![winfo ismapped $parent]} {
  405.             break
  406.         }
  407.         $parent activate none
  408.         $parent postcascade none
  409.         event generate $parent <<MenuSelect>>
  410.         if {([$parent cget -type] == "menubar")
  411.                 || ![wm overrideredirect $parent]} {
  412.             break
  413.         }
  414.         set menu $parent
  415.         }
  416.         if {[$menu cget -type] != "menubar"} {
  417.         $menu unpost
  418.         }
  419.     }
  420.     }
  421.  
  422.     if {($tkPriv(tearoff) != 0) || ($tkPriv(menuBar) != "")} {
  423.         # Release grab, if any, and restore the previous grab, if there
  424.         # was one.
  425.  
  426.     if {$menu != ""} {
  427.         set grab [grab current $menu]
  428.         if {$grab != ""} {
  429.         grab release $grab
  430.         }
  431.     }
  432.     tkRestoreOldGrab
  433.     if {$tkPriv(menuBar) != ""} {
  434.         $tkPriv(menuBar) configure -cursor $tkPriv(cursor)
  435.         set tkPriv(menuBar) {}
  436.     }
  437.     if {$tcl_platform(platform) != "unix"} {
  438.         set tkPriv(tearoff) 0
  439.     }
  440.     }
  441. }
  442.  
  443. # tkMbMotion --
  444. # This procedure handles mouse motion events inside menubuttons, and
  445. # also outside menubuttons when a menubutton has a grab (e.g. when a
  446. # menu selection operation is in progress).
  447. #
  448. # Arguments:
  449. # w -            The name of the menubutton widget.
  450. # upDown -         "down" means button 1 is pressed, "up" means
  451. #            it isn't.
  452. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  453.  
  454. proc tkMbMotion {w upDown rootx rooty} {
  455.     global tkPriv
  456.  
  457.     if {$tkPriv(inMenubutton) == $w} {
  458.     return
  459.     }
  460.     set new [winfo containing $rootx $rooty]
  461.     if {($new != $tkPriv(inMenubutton)) && (($new == "")
  462.         || ([winfo toplevel $new] == [winfo toplevel $w]))} {
  463.     if {$tkPriv(inMenubutton) != ""} {
  464.         tkMbLeave $tkPriv(inMenubutton)
  465.     }
  466.     if {($new != "") && ([winfo class $new] == "Menubutton")
  467.         && ([$new cget -indicatoron] == 0)
  468.         && ([$w cget -indicatoron] == 0)} {
  469.         if {$upDown == "down"} {
  470.         tkMbPost $new $rootx $rooty
  471.         } else {
  472.         tkMbEnter $new
  473.         }
  474.     }
  475.     }
  476. }
  477.  
  478. # tkMbButtonUp --
  479. # This procedure is invoked to handle button 1 releases for menubuttons.
  480. # If the release happens inside the menubutton then leave its menu
  481. # posted with element 0 activated.  Otherwise, unpost the menu.
  482. #
  483. # Arguments:
  484. # w -            The name of the menubutton widget.
  485.  
  486. proc tkMbButtonUp w {
  487.     global tkPriv
  488.     global tcl_platform
  489.  
  490.     set tearoff [expr {($tcl_platform(platform) == "unix") \
  491.              || ([[$w cget -menu] cget -type] == "tearoff")}]
  492.     if {($tearoff != 0) && ($tkPriv(postedMb) == $w) 
  493.         && ($tkPriv(inMenubutton) == $w)} {
  494.     tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
  495.     } else {
  496.     tkMenuUnpost {}
  497.     }
  498. }
  499.  
  500. # tkMenuMotion --
  501. # This procedure is called to handle mouse motion events for menus.
  502. # It does two things.  First, it resets the active element in the
  503. # menu, if the mouse is over the menu.  Second, if a mouse button
  504. # is down, it posts and unposts cascade entries to match the mouse
  505. # position.
  506. #
  507. # Arguments:
  508. # menu -        The menu window.
  509. # x -            The x position of the mouse.
  510. # y -            The y position of the mouse.
  511. # state -        Modifier state (tells whether buttons are down).
  512.  
  513. proc tkMenuMotion {menu x y state} {
  514.     global tkPriv
  515.     if {$menu == $tkPriv(window)} {
  516.     if {[$menu cget -type] == "menubar"} {
  517.         if {[info exists tkPriv(focus)] && \
  518.             ([string compare $menu $tkPriv(focus)] != 0)} {
  519.         $menu activate @$x,$y
  520.         event generate $menu <<MenuSelect>>
  521.         }
  522.     } else {
  523.         $menu activate @$x,$y
  524.         event generate $menu <<MenuSelect>>
  525.     }
  526.     }
  527.     if {($state & 0x1f00) != 0} {
  528.     $menu postcascade active
  529.     }
  530. }
  531.  
  532. # tkMenuButtonDown --
  533. # Handles button presses in menus.  There are a couple of tricky things
  534. # here:
  535. # 1. Change the posted cascade entry (if any) to match the mouse position.
  536. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  537. #    overrrides the implicit grab on button press, so that the menu
  538. #    button can track mouse motions over other menubuttons and change
  539. #    the posted menu.
  540. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  541. #    or one of its descendants) must grab to the top-level menu so that
  542. #    we can track mouse motions across the entire menu hierarchy.
  543. #
  544. # Arguments:
  545. # menu -        The menu window.
  546.  
  547. proc tkMenuButtonDown menu {
  548.     global tkPriv
  549.     global tcl_platform
  550.     $menu postcascade active
  551.     if {$tkPriv(postedMb) != ""} {
  552.     grab -global $tkPriv(postedMb)
  553.     } else {
  554.     while {(([$menu cget -type] != "menubar") 
  555.         && [wm overrideredirect $menu])
  556.         && ([winfo class [winfo parent $menu]] == "Menu")
  557.         && [winfo ismapped [winfo parent $menu]]} {
  558.         set menu [winfo parent $menu]
  559.     }
  560.  
  561.     if {$tkPriv(menuBar) == {}} {
  562.         set tkPriv(menuBar) $menu
  563.         set tkPriv(cursor) [$menu cget -cursor]
  564.         $menu configure -cursor arrow
  565.         }
  566.  
  567.     # Don't update grab information if the grab window isn't changing.
  568.     # Otherwise, we'll get an error when we unpost the menus and
  569.     # restore the grab, since the old grab window will not be viewable
  570.     # anymore.
  571.  
  572.     if {$menu != [grab current $menu]} {
  573.         tkSaveGrabInfo $menu
  574.     }
  575.  
  576.     # Must re-grab even if the grab window hasn't changed, in order
  577.     # to release the implicit grab from the button press.
  578.  
  579.     if {$tcl_platform(platform) == "unix"} {
  580.         grab -global $menu
  581.     }
  582.     }
  583. }
  584.  
  585. # tkMenuLeave --
  586. # This procedure is invoked to handle Leave events for a menu.  It
  587. # deactivates everything unless the active element is a cascade element
  588. # and the mouse is now over the submenu.
  589. #
  590. # Arguments:
  591. # menu -        The menu window.
  592. # rootx, rooty -    Root coordinates of mouse.
  593. # state -        Modifier state.
  594.  
  595. proc tkMenuLeave {menu rootx rooty state} {
  596.     global tkPriv
  597.     set tkPriv(window) {}
  598.     if {[$menu index active] == "none"} {
  599.     return
  600.     }
  601.     if {([$menu type active] == "cascade")
  602.         && ([winfo containing $rootx $rooty]
  603.         == [$menu entrycget active -menu])} {
  604.     return
  605.     }
  606.     $menu activate none
  607.     event generate $menu <<MenuSelect>>
  608. }
  609.  
  610. # tkMenuInvoke --
  611. # This procedure is invoked when button 1 is released over a menu.
  612. # It invokes the appropriate menu action and unposts the menu if
  613. # it came from a menubutton.
  614. #
  615. # Arguments:
  616. # w -            Name of the menu widget.
  617. # buttonRelease -    1 means this procedure is called because of
  618. #            a button release;  0 means because of keystroke.
  619.  
  620. proc tkMenuInvoke {w buttonRelease} {
  621.     global tkPriv
  622.  
  623.     if {$buttonRelease && ($tkPriv(window) == "")} {
  624.     # Mouse was pressed over a menu without a menu button, then
  625.     # dragged off the menu (possibly with a cascade posted) and
  626.     # released.  Unpost everything and quit.
  627.  
  628.     $w postcascade none
  629.     $w activate none
  630.     event generate $w <<MenuSelect>>
  631.     tkMenuUnpost $w
  632.     return
  633.     }
  634.     if {[$w type active] == "cascade"} {
  635.     $w postcascade active
  636.     set menu [$w entrycget active -menu]
  637.     tkMenuFirstEntry $menu
  638.     } elseif {[$w type active] == "tearoff"} {
  639.     tkMenuUnpost $w
  640.     tkTearOffMenu $w
  641.     } elseif {[$w cget -type] == "menubar"} {
  642.     $w postcascade none
  643.     $w activate none
  644.     event generate $w <<MenuSelect>>
  645.     tkMenuUnpost $w
  646.     } else {
  647.     tkMenuUnpost $w
  648.     uplevel #0 [list $w invoke active]
  649.     }
  650. }
  651.  
  652. # tkMenuEscape --
  653. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  654. # the given menu and, if it is the top-level menu for a menu button,
  655. # unposts the menu button as well.
  656. #
  657. # Arguments:
  658. # menu -        Name of the menu window.
  659.  
  660. proc tkMenuEscape menu {
  661.     set parent [winfo parent $menu]
  662.     if {([winfo class $parent] != "Menu")} {
  663.     tkMenuUnpost $menu
  664.     } elseif {([$parent cget -type] == "menubar")} {
  665.     tkMenuUnpost $menu
  666.     tkRestoreOldGrab
  667.     } else {
  668.     tkMenuNextMenu $menu left
  669.     }
  670. }
  671.  
  672. # The following routines handle arrow keys. Arrow keys behave
  673. # differently depending on whether the menu is a menu bar or not.
  674.  
  675. proc tkMenuUpArrow {menu} {
  676.     if {[$menu cget -type] == "menubar"} {
  677.     tkMenuNextMenu $menu left
  678.     } else {
  679.     tkMenuNextEntry $menu -1
  680.     }
  681. }
  682.  
  683. proc tkMenuDownArrow {menu} {
  684.     if {[$menu cget -type] == "menubar"} {
  685.     tkMenuNextMenu $menu right
  686.     } else {
  687.     tkMenuNextEntry $menu 1
  688.     }
  689. }
  690.  
  691. proc tkMenuLeftArrow {menu} {
  692.     if {[$menu cget -type] == "menubar"} {
  693.     tkMenuNextEntry $menu -1
  694.     } else {
  695.     tkMenuNextMenu $menu left
  696.     }
  697. }
  698.  
  699. proc tkMenuRightArrow {menu} {
  700.     if {[$menu cget -type] == "menubar"} {
  701.     tkMenuNextEntry $menu 1
  702.     } else {
  703.     tkMenuNextMenu $menu right
  704.     }
  705. }
  706.  
  707. # tkMenuNextMenu --
  708. # This procedure is invoked to handle "left" and "right" traversal
  709. # motions in menus.  It traverses to the next menu in a menu bar,
  710. # or into or out of a cascaded menu.
  711. #
  712. # Arguments:
  713. # menu -        The menu that received the keyboard
  714. #            event.
  715. # direction -        Direction in which to move: "left" or "right"
  716.  
  717. proc tkMenuNextMenu {menu direction} {
  718.     global tkPriv
  719.  
  720.     # First handle traversals into and out of cascaded menus.
  721.  
  722.     if {$direction == "right"} {
  723.     set count 1
  724.     set parent [winfo parent $menu]
  725.     set class [winfo class $parent]
  726.     if {[$menu type active] == "cascade"} {
  727.         $menu postcascade active
  728.         set m2 [$menu entrycget active -menu]
  729.         if {$m2 != ""} {
  730.         tkMenuFirstEntry $m2
  731.         }
  732.         return
  733.     } else {
  734.         set parent [winfo parent $menu]
  735.         while {($parent != ".")} {
  736.         if {([winfo class $parent] == "Menu")
  737.             && ([$parent cget -type] == "menubar")} {
  738.             tk_menuSetFocus $parent
  739.             tkMenuNextEntry $parent 1
  740.             return
  741.         }
  742.         set parent [winfo parent $parent]
  743.         }
  744.     }
  745.     } else {
  746.     set count -1
  747.     set m2 [winfo parent $menu]
  748.     if {[winfo class $m2] == "Menu"} {
  749.         $menu activate none
  750.         event generate $menu <<MenuSelect>>
  751.         tk_menuSetFocus $m2
  752.  
  753.         # This code unposts any posted submenu in the parent.
  754.  
  755.         set tmp [$m2 index active]
  756.         $m2 activate none
  757.         $m2 activate $tmp
  758.         return
  759.     }
  760.     }
  761.  
  762.     # Can't traverse into or out of a cascaded menu.  Go to the next
  763.     # or previous menubutton, if that makes sense.
  764.  
  765.     set w $tkPriv(postedMb)
  766.     if {$w == ""} {
  767.     return
  768.     }
  769.     set buttons [winfo children [winfo parent $w]]
  770.     set length [llength $buttons]
  771.     set i [expr [lsearch -exact $buttons $w] + $count]
  772.     while 1 {
  773.     while {$i < 0} {
  774.         incr i $length
  775.     }
  776.     while {$i >= $length} {
  777.         incr i -$length
  778.     }
  779.     set mb [lindex $buttons $i]
  780.     if {([winfo class $mb] == "Menubutton")
  781.         && ([$mb cget -state] != "disabled")
  782.         && ([$mb cget -menu] != "")
  783.         && ([[$mb cget -menu] index last] != "none")} {
  784.         break
  785.     }
  786.     if {$mb == $w} {
  787.         return
  788.     }
  789.     incr i $count
  790.     }
  791.     tkMbPost $mb
  792.     tkMenuFirstEntry [$mb cget -menu]
  793. }
  794.  
  795. # tkMenuNextEntry --
  796. # Activate the next higher or lower entry in the posted menu,
  797. # wrapping around at the ends.  Disabled entries are skipped.
  798. #
  799. # Arguments:
  800. # menu -            Menu window that received the keystroke.
  801. # count -            1 means go to the next lower entry,
  802. #                -1 means go to the next higher entry.
  803.  
  804. proc tkMenuNextEntry {menu count} {
  805.     global tkPriv
  806.  
  807.     if {[$menu index last] == "none"} {
  808.     return
  809.     }
  810.     set length [expr [$menu index last]+1]
  811.     set quitAfter $length
  812.     set active [$menu index active]
  813.     if {$active == "none"} {
  814.     set i 0
  815.     } else {
  816.     set i [expr $active + $count]
  817.     }
  818.     while 1 {
  819.     if {$quitAfter <= 0} {
  820.         # We've tried every entry in the menu.  Either there are
  821.         # none, or they're all disabled.  Just give up.
  822.  
  823.         return
  824.     }
  825.     while {$i < 0} {
  826.         incr i $length
  827.     }
  828.     while {$i >= $length} {
  829.         incr i -$length
  830.     }
  831.     if {[catch {$menu entrycget $i -state} state] == 0} {
  832.         if {$state != "disabled"} {
  833.         break
  834.         }
  835.     }
  836.     if {$i == $active} {
  837.         return
  838.     }
  839.     incr i $count
  840.     incr quitAfter -1
  841.     }
  842.     $menu activate $i
  843.     event generate $menu <<MenuSelect>>
  844.     $menu postcascade $i
  845. }
  846.  
  847. # tkMenuFind --
  848. # This procedure searches the entire window hierarchy under w for
  849. # a menubutton that isn't disabled and whose underlined character
  850. # is "char" or an entry in a menubar that isn't disabled and whose
  851. # underlined character is "char".
  852. # It returns the name of that window, if found, or an
  853. # empty string if no matching window was found.  If "char" is an
  854. # empty string then the procedure returns the name of the first
  855. # menubutton found that isn't disabled.
  856. #
  857. # Arguments:
  858. # w -                Name of window where key was typed.
  859. # char -            Underlined character to search for;
  860. #                may be either upper or lower case, and
  861. #                will match either upper or lower case.
  862.  
  863. proc tkMenuFind {w char} {
  864.     global tkPriv
  865.     set char [string tolower $char]
  866.     set windowlist [winfo child $w]
  867.  
  868.     foreach child $windowlist {
  869.     switch [winfo class $child] {
  870.         Menu {
  871.         if {[$child cget -type] == "menubar"} {
  872.             if {$char == ""} {
  873.             return $child
  874.             }
  875.             set last [$child index last]
  876.             for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
  877.             set char2 [string index [$child entrycget $i -label] \
  878.                 [$child entrycget $i -underline]]
  879.             if {([string compare $char [string tolower $char2]] \
  880.                 == 0) || ($char == "")} {
  881.                 if {[$child entrycget $i -state] != "disabled"} {
  882.                 return $child
  883.                 }
  884.             }
  885.             }
  886.         }
  887.         }
  888.     }
  889.     }
  890.  
  891.     foreach child $windowlist {
  892.     switch [winfo class $child] {
  893.         Menubutton {
  894.         set char2 [string index [$child cget -text] \
  895.             [$child cget -underline]]
  896.         if {([string compare $char [string tolower $char2]] == 0)
  897.             || ($char == "")} {
  898.             if {[$child cget -state] != "disabled"} {
  899.             return $child
  900.             }
  901.         }
  902.         }
  903.  
  904.         default {
  905.         set match [tkMenuFind $child $char]
  906.         if {$match != ""} {
  907.             return $match
  908.         }
  909.         }
  910.     }
  911.     }
  912.     return {}
  913. }
  914.  
  915. # tkTraverseToMenu --
  916. # This procedure implements keyboard traversal of menus.  Given an
  917. # ASCII character "char", it looks for a menubutton with that character
  918. # underlined.  If one is found, it posts the menubutton's menu
  919. #
  920. # Arguments:
  921. # w -                Window in which the key was typed (selects
  922. #                a toplevel window).
  923. # char -            Character that selects a menu.  The case
  924. #                is ignored.  If an empty string, nothing
  925. #                happens.
  926.  
  927. proc tkTraverseToMenu {w char} {
  928.     global tkPriv
  929.     if {$char == ""} {
  930.     return
  931.     }
  932.     while {[winfo class $w] == "Menu"} {
  933.     if {([$w cget -type] != "menubar") && ($tkPriv(postedMb) == "")} {
  934.         return
  935.     }
  936.     if {[$w cget -type] == "menubar"} {
  937.         break
  938.     }
  939.     set w [winfo parent $w]
  940.     }
  941.     set w [tkMenuFind [winfo toplevel $w] $char]
  942.     if {$w != ""} {
  943.     if {[winfo class $w] == "Menu"} {
  944.         tk_menuSetFocus $w
  945.         set tkPriv(window) $w
  946.         tkSaveGrabInfo $w
  947.         grab -global $w
  948.         tkTraverseWithinMenu $w $char
  949.     } else {
  950.         tkMbPost $w
  951.         tkMenuFirstEntry [$w cget -menu]
  952.     }
  953.     }
  954. }
  955.  
  956. # tkFirstMenu --
  957. # This procedure traverses to the first menubutton in the toplevel
  958. # for a given window, and posts that menubutton's menu.
  959. #
  960. # Arguments:
  961. # w -                Name of a window.  Selects which toplevel
  962. #                to search for menubuttons.
  963.  
  964. proc tkFirstMenu w {
  965.     set w [tkMenuFind [winfo toplevel $w] ""]
  966.     if {$w != ""} {
  967.     if {[winfo class $w] == "Menu"} {
  968.         tk_menuSetFocus $w
  969.         set tkPriv(window) $w
  970.         tkSaveGrabInfo $w
  971.         grab -global $w
  972.         tkMenuFirstEntry $w
  973.     } else {
  974.         tkMbPost $w
  975.         tkMenuFirstEntry [$w cget -menu]
  976.     }
  977.     }
  978. }
  979.  
  980. # tkTraverseWithinMenu
  981. # This procedure implements keyboard traversal within a menu.  It
  982. # searches for an entry in the menu that has "char" underlined.  If
  983. # such an entry is found, it is invoked and the menu is unposted.
  984. #
  985. # Arguments:
  986. # w -                The name of the menu widget.
  987. # char -            The character to look for;  case is
  988. #                ignored.  If the string is empty then
  989. #                nothing happens.
  990.  
  991. proc tkTraverseWithinMenu {w char} {
  992.     if {$char == ""} {
  993.     return
  994.     }
  995.     set char [string tolower $char]
  996.     set last [$w index last]
  997.     if {$last == "none"} {
  998.     return
  999.     }
  1000.     for {set i 0} {$i <= $last} {incr i} {
  1001.     if [catch {set char2 [string index \
  1002.         [$w entrycget $i -label] \
  1003.         [$w entrycget $i -underline]]}] {
  1004.         continue
  1005.     }
  1006.     if {[string compare $char [string tolower $char2]] == 0} {
  1007.         if {[$w type $i] == "cascade"} {
  1008.         $w activate $i
  1009.         $w postcascade active
  1010.         event generate $w <<MenuSelect>>
  1011.         set m2 [$w entrycget $i -menu]
  1012.         if {$m2 != ""} {
  1013.             tkMenuFirstEntry $m2
  1014.         }
  1015.         } else {
  1016.         tkMenuUnpost $w
  1017.         uplevel #0 [list $w invoke $i]
  1018.         }
  1019.         return
  1020.     }
  1021.     }
  1022. }
  1023.  
  1024. # tkMenuFirstEntry --
  1025. # Given a menu, this procedure finds the first entry that isn't
  1026. # disabled or a tear-off or separator, and activates that entry.
  1027. # However, if there is already an active entry in the menu (e.g.,
  1028. # because of a previous call to tkPostOverPoint) then the active
  1029. # entry isn't changed.  This procedure also sets the input focus
  1030. # to the menu.
  1031. #
  1032. # Arguments:
  1033. # menu -        Name of the menu window (possibly empty).
  1034.  
  1035. proc tkMenuFirstEntry menu {
  1036.     if {$menu == ""} {
  1037.     return
  1038.     }
  1039.     tk_menuSetFocus $menu
  1040.     if {[$menu index active] != "none"} {
  1041.     return
  1042.     }
  1043.     set last [$menu index last]
  1044.     if {$last == "none"} {
  1045.     return
  1046.     }
  1047.     for {set i 0} {$i <= $last} {incr i} {
  1048.     if {([catch {set state [$menu entrycget $i -state]}] == 0)
  1049.         && ($state != "disabled") && ([$menu type $i] != "tearoff")} {
  1050.         $menu activate $i
  1051.         event generate $menu <<MenuSelect>>
  1052.         return
  1053.     }
  1054.     }
  1055. }
  1056.  
  1057. # tkMenuFindName --
  1058. # Given a menu and a text string, return the index of the menu entry
  1059. # that displays the string as its label.  If there is no such entry,
  1060. # return an empty string.  This procedure is tricky because some names
  1061. # like "active" have a special meaning in menu commands, so we can't
  1062. # always use the "index" widget command.
  1063. #
  1064. # Arguments:
  1065. # menu -        Name of the menu widget.
  1066. # s -            String to look for.
  1067.  
  1068. proc tkMenuFindName {menu s} {
  1069.     set i ""
  1070.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  1071.     catch {set i [$menu index $s]}
  1072.     return $i
  1073.     }
  1074.     set last [$menu index last]
  1075.     if {$last == "none"} {
  1076.     return
  1077.     }
  1078.     for {set i 0} {$i <= $last} {incr i} {
  1079.     if ![catch {$menu entrycget $i -label} label] {
  1080.         if {$label == $s} {
  1081.         return $i
  1082.         }
  1083.     }
  1084.     }
  1085.     return ""
  1086. }
  1087.  
  1088. # tkPostOverPoint --
  1089. # This procedure posts a given menu such that a given entry in the
  1090. # menu is centered over a given point in the root window.  It also
  1091. # activates the given entry.
  1092. #
  1093. # Arguments:
  1094. # menu -        Menu to post.
  1095. # x, y -        Root coordinates of point.
  1096. # entry -        Index of entry within menu to center over (x,y).
  1097. #            If omitted or specified as {}, then the menu's
  1098. #            upper-left corner goes at (x,y).
  1099.  
  1100. proc tkPostOverPoint {menu x y {entry {}}}  {
  1101.     global tcl_platform
  1102.     
  1103.     if {$entry != {}} {
  1104.     if {$entry == [$menu index last]} {
  1105.         incr y [expr -([$menu yposition $entry] \
  1106.             + [winfo reqheight $menu])/2]
  1107.     } else {
  1108.         incr y [expr -([$menu yposition $entry] \
  1109.             + [$menu yposition [expr $entry+1]])/2]
  1110.     }
  1111.     incr x [expr -[winfo reqwidth $menu]/2]
  1112.     }
  1113.     $menu post $x $y
  1114.     if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  1115.     $menu activate $entry
  1116.     event generate $menu <<MenuSelect>>
  1117.     }
  1118. }
  1119.  
  1120. # tkSaveGrabInfo --
  1121. # Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record
  1122. # the state of any existing grab on the w's display.
  1123. #
  1124. # Arguments:
  1125. # w -            Name of a window;  used to select the display
  1126. #            whose grab information is to be recorded.
  1127.  
  1128. proc tkSaveGrabInfo w {
  1129.     global tkPriv
  1130.     set tkPriv(oldGrab) [grab current $w]
  1131.     if {$tkPriv(oldGrab) != ""} {
  1132.     set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]
  1133.     }
  1134. }
  1135.  
  1136. # tkRestoreOldGrab --
  1137. # Restores the grab to what it was before TkSaveGrabInfo was called.
  1138. #
  1139.  
  1140. proc tkRestoreOldGrab {} {
  1141.     global tkPriv
  1142.  
  1143.     if {$tkPriv(oldGrab) != ""} {
  1144.  
  1145.         # Be careful restoring the old grab, since it's window may not
  1146.     # be visible anymore.
  1147.  
  1148.     catch {
  1149.         if {$tkPriv(grabStatus) == "global"} {
  1150.         grab set -global $tkPriv(oldGrab)
  1151.         } else {
  1152.         grab set $tkPriv(oldGrab)
  1153.         }
  1154.     }
  1155.     set tkPriv(oldGrab) ""
  1156.     }
  1157. }
  1158.  
  1159. proc tk_menuSetFocus {menu} {
  1160.     global tkPriv
  1161.     if {![info exists tkPriv(focus)] || [string length $tkPriv(focus)] == 0} {
  1162.     set tkPriv(focus) [focus]
  1163.     }
  1164.     focus $menu
  1165. }
  1166.     
  1167. # tk_popup --
  1168. # This procedure pops up a menu and sets things up for traversing
  1169. # the menu and its submenus.
  1170. #
  1171. # Arguments:
  1172. # menu -        Name of the menu to be popped up.
  1173. # x, y -        Root coordinates at which to pop up the
  1174. #            menu.
  1175. # entry -        Index of a menu entry to center over (x,y).
  1176. #            If omitted or specified as {}, then menu's
  1177. #            upper-left corner goes at (x,y).
  1178.  
  1179. proc tk_popup {menu x y {entry {}}} {
  1180.     global tkPriv
  1181.     global tcl_platform
  1182.     if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} {
  1183.     tkMenuUnpost {}
  1184.     }
  1185.     tkPostOverPoint $menu $x $y $entry
  1186.     if {$tcl_platform(platform) == "unix"} {
  1187.     tkSaveGrabInfo $menu
  1188.     grab -global $menu
  1189.     set tkPriv(popup) $menu
  1190.     tk_menuSetFocus($menu);
  1191.     }
  1192. }
  1193.